home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / f2c-9510.000 / f2c-9510 / f2c-951007-libs-1.1 / src / format.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-10-07  |  56.3 KB  |  2,518 lines
  1. /****************************************************************
  2. Copyright 1990 - 1995 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. /* Format.c -- this file takes an intermediate file (generated by pass 1
  25.    of the translator) and some state information about the contents of that
  26.    file, and generates C program text. */
  27.  
  28. #include "defs.h"
  29. #include "p1defs.h"
  30. #include "format.h"
  31. #include "output.h"
  32. #include "names.h"
  33. #include "iob.h"
  34.  
  35. int c_output_line_length = DEF_C_LINE_LENGTH;
  36.  
  37. int last_was_label;    /* Boolean used to generate semicolons
  38.                    when a label terminates a block */
  39. static char this_proc_name[52];    /* Name of the current procedure.  This is
  40.                    probably too simplistic to handle
  41.                    multiple entry points */
  42.  
  43. static tagptr do_format Argdcl((FILEP, FILEP));
  44. static void do_p1_1while Argdcl((FILEP));
  45. static void do_p1_2while Argdcl((FILEP, FILEP));
  46. static tagptr do_p1_addr Argdcl((FILEP, FILEP));
  47. static void do_p1_asgoto Argdcl((FILEP, FILEP));
  48. static tagptr do_p1_charp Argdcl((FILEP));
  49. static void do_p1_comment Argdcl((FILEP, FILEP));
  50. static void do_p1_comp_goto Argdcl((FILEP, FILEP));
  51. static tagptr do_p1_const Argdcl((FILEP));
  52. static void do_p1_elif Argdcl((FILEP, FILEP));
  53. static void do_p1_else Argdcl((FILEP));
  54. static void do_p1_elseifstart Argdcl((FILEP));
  55. static void do_p1_end_for Argdcl((FILEP));
  56. static void do_p1_endelse Argdcl((FILEP));
  57. static void do_p1_endif Argdcl((FILEP));
  58. static tagptr do_p1_expr Argdcl((FILEP, FILEP));
  59. static tagptr do_p1_extern Argdcl((FILEP));
  60. static void do_p1_for Argdcl((FILEP, FILEP));
  61. static void do_p1_fortran Argdcl((FILEP, FILEP));
  62. static void do_p1_goto Argdcl((FILEP, FILEP));
  63. static tagptr do_p1_head Argdcl((FILEP, FILEP));
  64. static tagptr do_p1_ident Argdcl((FILEP));
  65. static void do_p1_if Argdcl((FILEP, FILEP));
  66. static void do_p1_label Argdcl((FILEP, FILEP));
  67. static tagptr do_p1_list Argdcl((FILEP, FILEP));
  68. static tagptr do_p1_literal Argdcl((FILEP));
  69. static tagptr do_p1_name_pointer Argdcl((FILEP));
  70. static void do_p1_set_line Argdcl((FILEP));
  71. static void do_p1_subr_ret Argdcl((FILEP, FILEP));
  72. static int get_p1_token Argdcl((FILEP));
  73. static int p1get_const Argdcl((FILEP, int, Constp*));
  74. static int p1getd Argdcl((FILEP, long int*));
  75. static int p1getf Argdcl((FILEP, char**));
  76. static int p1getn Argdcl((FILEP, int, char**));
  77. static int p1gets Argdcl((FILEP, char*, int));
  78. static void proto Argdcl((FILEP, Argtypes*, char*));
  79.  
  80. extern chainp assigned_fmts;
  81. char filename[P1_FILENAME_MAX];
  82. extern int gflag, sharp_line;
  83. int gflag1;
  84. extern char *parens;
  85.  
  86.  void
  87. start_formatting(Void)
  88. {
  89.     FILE *infile;
  90.     static int wrote_one = 0;
  91.     extern int usedefsforcommon;
  92.     extern char *p1_file, *p1_bakfile;
  93.  
  94.     this_proc_name[0] = '\0';
  95.     last_was_label = 0;
  96.     ei_next = ei_first;
  97.     wh_next = wh_first;
  98.  
  99.     (void) fclose (pass1_file);
  100.     if ((infile = fopen (p1_file, binread)) == NULL)
  101.     Fatal("start_formatting:  couldn't open the intermediate file\n");
  102.  
  103.     if (wrote_one)
  104.     nice_printf (c_file, "\n");
  105.  
  106.     while (!feof (infile)) {
  107.     expptr this_expr;
  108.  
  109.     this_expr = do_format (infile, c_file);
  110.     if (this_expr) {
  111.         out_and_free_statement (c_file, this_expr);
  112.     } /* if this_expr */
  113.     } /* while !feof infile */
  114.  
  115.     (void) fclose (infile);
  116.  
  117.     if (last_was_label)
  118.     nice_printf (c_file, ";\n");
  119.  
  120.     prev_tab (c_file);
  121.     gflag1 = sharp_line = 0;
  122.     if (this_proc_name[0])
  123.     nice_printf (c_file, "} /* %s */\n", this_proc_name);
  124.  
  125.  
  126. /* Write the #undefs for common variable reference */
  127.  
  128.     if (usedefsforcommon) {
  129.     Extsym *ext;
  130.     int did_one = 0;
  131.  
  132.     for (ext = extsymtab; ext < nextext; ext++)
  133.         if (ext -> extstg == STGCOMMON && ext -> used_here) {
  134.         ext -> used_here = 0;
  135.         if (!did_one)
  136.             nice_printf (c_file, "\n");
  137.         wr_abbrevs(c_file, 0, ext->extp);
  138.         did_one = 1;
  139.         ext -> extp = CHNULL;
  140.         } /* if */
  141.  
  142.     if (did_one)
  143.         nice_printf (c_file, "\n");
  144.     } /* if usedefsforcommon */
  145.  
  146.     other_undefs(c_file);
  147.  
  148.     wrote_one = 1;
  149.  
  150. /* For debugging only */
  151.  
  152.     if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite)))
  153.     if (infile = fopen (p1_file, binread)) {
  154.         ffilecopy (infile, pass1_file);
  155.         fclose (infile);
  156.         fclose (pass1_file);
  157.     } /* if infile */
  158.  
  159. /* End of "debugging only" */
  160.  
  161.     scrub(p1_file);    /* optionally unlink */
  162.  
  163.     if ((pass1_file = fopen (p1_file, binwrite)) == NULL)
  164.     err ("start_formatting:  couldn't reopen the pass1 file");
  165.  
  166. } /* start_formatting */
  167.  
  168.  
  169.  static void
  170. #ifdef KR_headers
  171. put_semi(outfile)
  172.     FILE *outfile;
  173. #else
  174. put_semi(FILE *outfile)
  175. #endif
  176. {
  177.     nice_printf (outfile, ";\n");
  178.     last_was_label = 0;
  179.     }
  180.  
  181. #define SEM_CHECK(x) if (last_was_label) put_semi(x)
  182.  
  183. /* do_format -- takes an input stream (a file in pass1 format) and writes
  184.    the appropriate C code to   outfile   when possible.  When reading an
  185.    expression, the expression tree is returned instead. */
  186.  
  187.  static expptr
  188. #ifdef KR_headers
  189. do_format(infile, outfile)
  190.     FILE *infile;
  191.     FILE *outfile;
  192. #else
  193. do_format(FILE *infile, FILE *outfile)
  194. #endif
  195. {
  196.     int token_type, was_c_token;
  197.     expptr retval = ENULL;
  198.  
  199.     token_type = get_p1_token (infile);
  200.     was_c_token = 1;
  201.     switch (token_type) {
  202.     case P1_COMMENT:
  203.         do_p1_comment (infile, outfile);
  204.         was_c_token = 0;
  205.         break;
  206.     case P1_SET_LINE:
  207.         do_p1_set_line (infile);
  208.         was_c_token = 0;
  209.         break;
  210.     case P1_FILENAME:
  211.         p1gets(infile, filename, P1_FILENAME_MAX);
  212.         was_c_token = 0;
  213.         break;
  214.     case P1_NAME_POINTER:
  215.         retval = do_p1_name_pointer (infile);
  216.         break;
  217.     case P1_CONST:
  218.         retval = do_p1_const (infile);
  219.         break;
  220.     case P1_EXPR:
  221.         retval = do_p1_expr (infile, outfile);
  222.         break;
  223.     case P1_IDENT:
  224.         retval = do_p1_ident(infile);
  225.         break;
  226.     case P1_CHARP:
  227.         retval = do_p1_charp(infile);
  228.         break;
  229.     case P1_EXTERN:
  230.         retval = do_p1_extern (infile);
  231.         break;
  232.     case P1_HEAD:
  233.         gflag1 = sharp_line = 0;
  234.         retval = do_p1_head (infile, outfile);
  235.         gflag1 = sharp_line = gflag;
  236.         break;
  237.     case P1_LIST:
  238.         retval = do_p1_list (infile, outfile);
  239.         break;
  240.     case P1_LITERAL:
  241.         retval = do_p1_literal (infile);
  242.         break;
  243.     case P1_LABEL:
  244.         do_p1_label (infile, outfile);
  245.         /* last_was_label = 1; -- now set in do_p1_label */
  246.         was_c_token = 0;
  247.         break;
  248.     case P1_ASGOTO:
  249.         do_p1_asgoto (infile, outfile);
  250.         break;
  251.     case P1_GOTO:
  252.         do_p1_goto (infile, outfile);
  253.         break;
  254.     case P1_IF:
  255.         do_p1_if (infile, outfile);
  256.         break;
  257.     case P1_ELSE:
  258.         SEM_CHECK(outfile);
  259.         do_p1_else (outfile);
  260.         break;
  261.     case P1_ELIF:
  262.         SEM_CHECK(outfile);
  263.         do_p1_elif (infile, outfile);
  264.         break;
  265.     case P1_ENDIF:
  266.         SEM_CHECK(outfile);
  267.         do_p1_endif (outfile);
  268.         break;
  269.     case P1_ENDELSE:
  270.         SEM_CHECK(outfile);
  271.         do_p1_endelse (outfile);
  272.         break;
  273.     case P1_ADDR:
  274.         retval = do_p1_addr (infile, outfile);
  275.         break;
  276.     case P1_SUBR_RET:
  277.         do_p1_subr_ret (infile, outfile);
  278.         break;
  279.     case P1_COMP_GOTO:
  280.         do_p1_comp_goto (infile, outfile);
  281.         break;
  282.     case P1_FOR:
  283.         do_p1_for (infile, outfile);
  284.         break;
  285.     case P1_ENDFOR:
  286.         SEM_CHECK(outfile);
  287.         do_p1_end_for (outfile);
  288.         break;
  289.     case P1_WHILE1START:
  290.         do_p1_1while(outfile);
  291.         break;
  292.     case P1_WHILE2START:
  293.         do_p1_2while(infile, outfile);
  294.         break;
  295.     case P1_PROCODE:
  296.         procode(outfile);
  297.         break;
  298.     case P1_ELSEIFSTART:
  299.         SEM_CHECK(outfile);
  300.         do_p1_elseifstart(outfile);
  301.         break;
  302.     case P1_FORTRAN:
  303.         do_p1_fortran(infile, outfile);
  304.         /* no break; */
  305.     case P1_EOF:
  306.         was_c_token = 0;
  307.         break;
  308.     case P1_UNKNOWN:
  309.         Fatal("do_format:  Unknown token type in intermediate file");
  310.         break;
  311.     default:
  312.         Fatal("do_format:  Bad token type in intermediate file");
  313.         break;
  314.    } /* switch */
  315.  
  316.     if (was_c_token)
  317.     last_was_label = 0;
  318.     return retval;
  319. } /* do_format */
  320.  
  321.  
  322.  static void
  323. #ifdef KR_headers
  324. do_p1_comment(infile, outfile)
  325.     FILE *infile;
  326.     FILE *outfile;
  327. #else
  328. do_p1_comment(FILE *infile, FILE *outfile)
  329. #endif
  330. {
  331.     extern int c_output_line_length, in_comment;
  332.  
  333.     char storage[COMMENT_BUFFER_SIZE + 1];
  334.     int length;
  335.  
  336.     if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1))
  337.     return;
  338.  
  339.     length = strlen (storage);
  340.  
  341.     gflag1 = sharp_line = 0;
  342.     in_comment = 1;
  343.     if (length > c_output_line_length - 6)
  344.     margin_printf(outfile, "/*%s*/\n", storage);
  345.     else
  346.     margin_printf(outfile, length ? "/* %s */\n" : "\n", storage);
  347.     in_comment = 0;
  348.     gflag1 = sharp_line = gflag;
  349. } /* do_p1_comment */
  350.  
  351.  static void
  352. #ifdef KR_headers
  353. do_p1_set_line(infile)
  354.     FILE *infile;
  355. #else
  356. do_p1_set_line(FILE *infile)
  357. #endif
  358. {
  359.     int status;
  360.     long new_line_number = -1;
  361.  
  362.     status = p1getd (infile, &new_line_number);
  363.  
  364.     if (status == EOF)
  365.     err ("do_p1_set_line:  Missing line number at end of file\n");
  366.     else if (status == 0 || new_line_number == -1)
  367.     errl("do_p1_set_line:  Illegal line number in intermediate file: %ld\n",
  368.         new_line_number);
  369.     else {
  370.     lineno = new_line_number;
  371.     }
  372. } /* do_p1_set_line */
  373.  
  374.  
  375.  static expptr
  376. #ifdef KR_headers
  377. do_p1_name_pointer(infile)
  378.     FILE *infile;
  379. #else
  380. do_p1_name_pointer(FILE *infile)
  381. #endif
  382. {
  383.     Namep namep = (Namep) NULL;
  384.     int status;
  385.  
  386.     status = p1getd (infile, (long *) &namep);
  387.  
  388.     if (status == EOF)
  389.     err ("do_p1_name_pointer:  Missing pointer at end of file\n");
  390.     else if (status == 0 || namep == (Namep) NULL)
  391.     erri ("do_p1_name_pointer:  Illegal name pointer in p1 file: '%x'\n",
  392.         (int) namep);
  393.  
  394.     return (expptr) namep;
  395. } /* do_p1_name_pointer */
  396.  
  397.  
  398.  
  399.  static expptr
  400. #ifdef KR_headers
  401. do_p1_const(infile)
  402.     FILE *infile;
  403. #else
  404. do_p1_const(FILE *infile)
  405. #endif
  406. {
  407.     struct Constblock *c = (struct Constblock *) NULL;
  408.     long type = -1;
  409.     int status;
  410.  
  411.     status = p1getd (infile, &type);
  412.  
  413.     if (status == EOF)
  414.     err ("do_p1_const:  Missing constant type at end of file\n");
  415.     else if (status == 0)
  416.     errl("do_p1_const:  Illegal constant type in p1 file: %ld\n", type);
  417.     else {
  418.     status = p1get_const (infile, (int)type, &c);
  419.  
  420.     if (status == EOF) {
  421.         err ("do_p1_const:  Missing constant value at end of file\n");
  422.         c = (struct Constblock *) NULL;
  423.     } else if (status == 0) {
  424.         err ("do_p1_const:  Illegal constant value in p1 file\n");
  425.         c = (struct Constblock *) NULL;
  426.     } /* else */
  427.     } /* else */
  428.     return (expptr) c;
  429. } /* do_p1_const */
  430.  
  431.  void
  432. #ifdef KR_headers
  433. addrlit(addrp)
  434.     Addrp addrp;
  435. #else
  436. addrlit(Addrp addrp)
  437. #endif
  438. {
  439.     int memno = addrp->memno;
  440.     struct Literal *litp, *lastlit;
  441.  
  442.     lastlit = litpool + nliterals;
  443.     for (litp = litpool; litp < lastlit; litp++)
  444.         if (litp->litnum == memno) {
  445.         addrp->vtype = litp->littype;
  446.         *((union Constant *) &(addrp->user)) =
  447.             *((union Constant *) &(litp->litval));
  448.         addrp->vstg = STGMEMNO;
  449.         return;
  450.         }
  451.     err("addrlit failure!");
  452.     }
  453.  
  454.  static expptr
  455. #ifdef KR_headers
  456. do_p1_literal(infile)
  457.     FILE *infile;
  458. #else
  459. do_p1_literal(FILE *infile)
  460. #endif
  461. {
  462.     int status;
  463.     long memno;
  464.     Addrp addrp;
  465.  
  466.     status = p1getd (infile, &memno);
  467.  
  468.     if (status == EOF)
  469.     err ("do_p1_literal:  Missing memno at end of file");
  470.     else if (status == 0)
  471.     err ("do_p1_literal:  Missing memno in p1 file");
  472.     else {
  473.     addrp = ALLOC (Addrblock);
  474.     addrp -> tag = TADDR;
  475.     addrp -> vtype = TYUNKNOWN;
  476.     addrp -> Field = NULL;
  477.     addrp -> memno = memno;
  478.     addrlit(addrp);
  479.     addrp -> uname_tag = UNAM_CONST;
  480.     } /* else */
  481.  
  482.     return (expptr) addrp;
  483. } /* do_p1_literal */
  484.  
  485.  
  486.  static void
  487. #ifdef KR_headers
  488. do_p1_label(infile, outfile)
  489.     FILE *infile;
  490.     FILE *outfile;
  491. #else
  492. do_p1_label(FILE *infile, FILE *outfile)
  493. #endif
  494. {
  495.     int status;
  496.     ftnint stateno;
  497.     struct Labelblock *L;
  498.     char *fmt;
  499.  
  500.     status = p1getd (infile, &stateno);
  501.  
  502.     if (status == EOF)
  503.     err ("do_p1_label:  Missing label at end of file");
  504.     else if (status == 0)
  505.     err ("do_p1_label:  Missing label in p1 file ");
  506.     else if (stateno < 0) {    /* entry */
  507.     margin_printf(outfile, "\n%s:\n", user_label(stateno));
  508.     last_was_label = 1;
  509.     }
  510.     else {
  511.     L = labeltab + stateno;
  512.     if (L->labused) {
  513.         fmt = "%s:\n";
  514.         last_was_label = 1;
  515.         }
  516.     else
  517.         fmt = "/* %s: */\n";
  518.     margin_printf(outfile, fmt, user_label(L->stateno));
  519.     } /* else */
  520. } /* do_p1_label */
  521.  
  522.  
  523.  
  524.  static void
  525. #ifdef KR_headers
  526. do_p1_asgoto(infile, outfile)
  527.     FILE *infile;
  528.     FILE *outfile;
  529. #else
  530. do_p1_asgoto(FILE *infile, FILE *outfile)
  531. #endif
  532. {
  533.     expptr expr;
  534.  
  535.     expr = do_format (infile, outfile);
  536.     out_asgoto (outfile, expr);
  537.  
  538. } /* do_p1_asgoto */
  539.  
  540.  
  541.  static void
  542. #ifdef KR_headers
  543. do_p1_goto(infile, outfile)
  544.     FILE *infile;
  545.     FILE *outfile;
  546. #else
  547. do_p1_goto(FILE *infile, FILE *outfile)
  548. #endif
  549. {
  550.     int status;
  551.     long stateno;
  552.  
  553.     status = p1getd (infile, &stateno);
  554.  
  555.     if (status == EOF)
  556.     err ("do_p1_goto:  Missing goto label at end of file");
  557.     else if (status == 0)
  558.     err ("do_p1_goto:  Missing goto label in p1 file");
  559.     else {
  560.     nice_printf (outfile, "goto %s;\n", user_label (stateno));
  561.     } /* else */
  562. } /* do_p1_goto */
  563.  
  564.  
  565.  static void
  566. #ifdef KR_headers
  567. do_p1_if(infile, outfile)
  568.     FILE *infile;
  569.     FILE *outfile;
  570. #else
  571. do_p1_if(FILE *infile, FILE *outfile)
  572. #endif
  573. {
  574.     expptr cond;
  575.  
  576.     do {
  577.         cond = do_format (infile, outfile);
  578.     } while (cond == ENULL);
  579.  
  580.     out_if (outfile, cond);
  581. } /* do_p1_if */
  582.  
  583.  
  584.  static void
  585. #ifdef KR_headers
  586. do_p1_else(outfile)
  587.     FILE *outfile;
  588. #else
  589. do_p1_else(FILE *outfile)
  590. #endif
  591. {
  592.     out_else (outfile);
  593. } /* do_p1_else */
  594.  
  595.  
  596.  static void
  597. #ifdef KR_headers
  598. do_p1_elif(infile, outfile)
  599.     FILE *infile;
  600.     FILE *outfile;
  601. #else
  602. do_p1_elif(FILE *infile, FILE *outfile)
  603. #endif
  604. {
  605.     expptr cond;
  606.  
  607.     do {
  608.         cond = do_format (infile, outfile);
  609.     } while (cond == ENULL);
  610.  
  611.     elif_out (outfile, cond);
  612. } /* do_p1_elif */
  613.  
  614.  static void
  615. #ifdef KR_headers
  616. do_p1_endif(outfile)
  617.     FILE *outfile;
  618. #else
  619. do_p1_endif(FILE *outfile)
  620. #endif
  621. {
  622.     endif_out (outfile);
  623. } /* do_p1_endif */
  624.  
  625.  
  626.  static void
  627. #ifdef KR_headers
  628. do_p1_endelse(outfile)
  629.     FILE *outfile;
  630. #else
  631. do_p1_endelse(FILE *outfile)
  632. #endif
  633. {
  634.     end_else_out (outfile);
  635. } /* do_p1_endelse */
  636.  
  637.  
  638.  static expptr
  639. #ifdef KR_headers
  640. do_p1_addr(infile, outfile)
  641.     FILE *infile;
  642.     FILE *outfile;
  643. #else
  644. do_p1_addr(FILE *infile, FILE *outfile)
  645. #endif
  646. {
  647.     Addrp addrp = (Addrp) NULL;
  648.     int status;
  649.  
  650.     status = p1getn (infile, (int)sizeof(struct Addrblock), (char **) &addrp);
  651.  
  652.     if (status == EOF)
  653.     err ("do_p1_addr:  Missing Addrp at end of file");
  654.     else if (status == 0)
  655.     err ("do_p1_addr:  Missing Addrp in p1 file");
  656.     else if (addrp == (Addrp) NULL)
  657.     err ("do_p1_addr:  Null addrp in p1 file");
  658.     else if (addrp -> tag != TADDR)
  659.     erri ("do_p1_addr: bad tag in p1 file '%d'", addrp -> tag);
  660.     else {
  661.     addrp -> vleng = do_format (infile, outfile);
  662.     addrp -> memoffset = do_format (infile, outfile);
  663.     }
  664.  
  665.     return (expptr) addrp;
  666. } /* do_p1_addr */
  667.  
  668.  
  669.  
  670.  static void
  671. #ifdef KR_headers
  672. do_p1_subr_ret(infile, outfile)
  673.     FILE *infile;
  674.     FILE *outfile;
  675. #else
  676. do_p1_subr_ret(FILE *infile, FILE *outfile)
  677. #endif
  678. {
  679.     expptr retval;
  680.  
  681.     nice_printf (outfile, "return ");
  682.     retval = do_format (infile, outfile);
  683.     if (!multitype)
  684.     if (retval)
  685.         expr_out (outfile, retval);
  686.  
  687.     nice_printf (outfile, ";\n");
  688. } /* do_p1_subr_ret */
  689.  
  690.  
  691.  
  692.  static void
  693. #ifdef KR_headers
  694. do_p1_comp_goto(infile, outfile)
  695.     FILE *infile;
  696.     FILE *outfile;
  697. #else
  698. do_p1_comp_goto(FILE *infile, FILE *outfile)
  699. #endif
  700. {
  701.     expptr index;
  702.     expptr labels;
  703.  
  704.     index = do_format (infile, outfile);
  705.  
  706.     if (index == ENULL) {
  707.     err ("do_p1_comp_goto:  no expression for computed goto");
  708.     return;
  709.     } /* if index == ENULL */
  710.  
  711.     labels = do_format (infile, outfile);
  712.  
  713.     if (labels && labels -> tag != TLIST)
  714.     erri ("do_p1_comp_goto:  expected list, got tag '%d'", labels -> tag);
  715.     else
  716.     compgoto_out (outfile, index, labels);
  717. } /* do_p1_comp_goto */
  718.  
  719.  
  720.  static void
  721. #ifdef KR_headers
  722. do_p1_for(infile, outfile)
  723.     FILE *infile;
  724.     FILE *outfile;
  725. #else
  726. do_p1_for(FILE *infile, FILE *outfile)
  727. #endif
  728. {
  729.     expptr init, test, inc;
  730.  
  731.     init = do_format (infile, outfile);
  732.     test = do_format (infile, outfile);
  733.     inc = do_format (infile, outfile);
  734.  
  735.     out_for (outfile, init, test, inc);
  736. } /* do_p1_for */
  737.  
  738.  static void
  739. #ifdef KR_headers
  740. do_p1_end_for(outfile)
  741.     FILE *outfile;
  742. #else
  743. do_p1_end_for(FILE *outfile)
  744. #endif
  745. {
  746.     out_end_for (outfile);
  747. } /* do_p1_end_for */
  748.  
  749.  
  750.  static void
  751. #ifdef KR_headers
  752. do_p1_fortran(infile, outfile)
  753.     FILE *infile;
  754.     FILE *outfile;
  755. #else
  756. do_p1_fortran(FILE *infile, FILE *outfile)
  757. #endif
  758. {
  759.     char buf[P1_STMTBUFSIZE];
  760.     if (!p1gets(infile, buf, P1_STMTBUFSIZE))
  761.         return;
  762.     /* bypass nice_printf nonsense */
  763.     fprintf(outfile, "/*< %s >*/\n", buf+1);    /* + 1 to skip by '$' */
  764.     }
  765.  
  766.  
  767.  static expptr
  768. #ifdef KR_headers
  769. do_p1_expr(infile, outfile)
  770.     FILE *infile;
  771.     FILE *outfile;
  772. #else
  773. do_p1_expr(FILE *infile, FILE *outfile)
  774. #endif
  775. {
  776.     int status;
  777.     long opcode, type;
  778.     struct Exprblock *result = (struct Exprblock *) NULL;
  779.  
  780.     status = p1getd (infile, &opcode);
  781.  
  782.     if (status == EOF)
  783.     err ("do_p1_expr:  Missing expr opcode at end of file");
  784.     else if (status == 0)
  785.     err ("do_p1_expr:  Missing expr opcode in p1 file");
  786.     else {
  787.  
  788.     status = p1getd (infile, &type);
  789.  
  790.     if (status == EOF)
  791.         err ("do_p1_expr:  Missing expr type at end of file");
  792.     else if (status == 0)
  793.         err ("do_p1_expr:  Missing expr type in p1 file");
  794.     else if (opcode == 0)
  795.         return ENULL;
  796.     else {
  797.         result = ALLOC (Exprblock);
  798.  
  799.         result -> tag = TEXPR;
  800.         result -> vtype = type;
  801.         result -> opcode = opcode;
  802.         result -> vleng = do_format (infile, outfile);
  803.  
  804.         if (is_unary_op (opcode))
  805.         result -> leftp = do_format (infile, outfile);
  806.         else if (is_binary_op (opcode)) {
  807.         result -> leftp = do_format (infile, outfile);
  808.         result -> rightp = do_format (infile, outfile);
  809.         } else
  810.         errl("do_p1_expr:  Illegal opcode %ld", opcode);
  811.     } /* else */
  812.     } /* else */
  813.  
  814.     return (expptr) result;
  815. } /* do_p1_expr */
  816.  
  817.  
  818.  static expptr
  819. #ifdef KR_headers
  820. do_p1_ident(infile)
  821.     FILE *infile;
  822. #else
  823. do_p1_ident(FILE *infile)
  824. #endif
  825. {
  826.     Addrp addrp;
  827.     int status;
  828.     long vtype, vstg;
  829.  
  830.     addrp = ALLOC (Addrblock);
  831.     addrp -> tag = TADDR;
  832.  
  833.     status = p1getd (infile, &vtype);
  834.     if (status == EOF)
  835.         err ("do_p1_ident:  Missing identifier type at end of file\n");
  836.     else if (status == 0 || vtype < 0 || vtype >= NTYPES)
  837.         errl("do_p1_ident:  Bad type in intermediate file: %ld\n", vtype);
  838.     else
  839.         addrp -> vtype = vtype;
  840.  
  841.     status = p1getd (infile, &vstg);
  842.     if (status == EOF)
  843.         err ("do_p1_ident:  Missing identifier storage at end of file\n");
  844.     else if (status == 0 || vstg < 0 || vstg > STGNULL)
  845.         errl("do_p1_ident:  Bad storage in intermediate file: %ld\n", vtype);
  846.     else
  847.         addrp -> vstg = vstg;
  848.  
  849.     status = p1gets(infile, addrp->user.ident, IDENT_LEN);
  850.  
  851.     if (status == EOF)
  852.         err ("do_p1_ident:  Missing ident string at end of file");
  853.     else if (status == 0)
  854.         err ("do_p1_ident:  Missing ident string in intermediate file");
  855.     addrp->uname_tag = UNAM_IDENT;
  856.     return (expptr) addrp;
  857. } /* do_p1_ident */
  858.  
  859.  static expptr
  860. #ifdef KR_headers
  861. do_p1_charp(infile)
  862.     FILE *infile;
  863. #else
  864. do_p1_charp(FILE *infile)
  865. #endif
  866. {
  867.     Addrp addrp;
  868.     int status;
  869.     long vtype, vstg;
  870.     char buf[64];
  871.  
  872.     addrp = ALLOC (Addrblock);
  873.     addrp -> tag = TADDR;
  874.  
  875.     status = p1getd (infile, &vtype);
  876.     if (status == EOF)
  877.         err ("do_p1_ident:  Missing identifier type at end of file\n");
  878.     else if (status == 0 || vtype < 0 || vtype >= NTYPES)
  879.         errl("do_p1_ident:  Bad type in intermediate file: %ld\n", vtype);
  880.     else
  881.         addrp -> vtype = vtype;
  882.  
  883.     status = p1getd (infile, &vstg);
  884.     if (status == EOF)
  885.         err ("do_p1_ident:  Missing identifier storage at end of file\n");
  886.     else if (status == 0 || vstg < 0 || vstg > STGNULL)
  887.         errl("do_p1_ident:  Bad storage in intermediate file: %ld\n", vtype);
  888.     else
  889.         addrp -> vstg = vstg;
  890.  
  891.     status = p1gets(infile, buf, (int)sizeof(buf));
  892.  
  893.     if (status == EOF)
  894.         err ("do_p1_ident:  Missing charp ident string at end of file");
  895.     else if (status == 0)
  896.         err ("do_p1_ident:  Missing charp ident string in intermediate file");
  897.     addrp->uname_tag = UNAM_CHARP;
  898.     addrp->user.Charp = strcpy(mem(strlen(buf)+1,0), buf);
  899.     return (expptr) addrp;
  900. }
  901.  
  902.  
  903.  static expptr
  904. #ifdef KR_headers
  905. do_p1_extern(infile)
  906.     FILE *infile;
  907. #else
  908. do_p1_extern(FILE *infile)
  909. #endif
  910. {
  911.     Addrp addrp;
  912.  
  913.     addrp = ALLOC (Addrblock);
  914.     if (addrp) {
  915.     int status;
  916.  
  917.     addrp->tag = TADDR;
  918.     addrp->vstg = STGEXT;
  919.     addrp->uname_tag = UNAM_EXTERN;
  920.     status = p1getd (infile, &(addrp -> memno));
  921.     if (status == EOF)
  922.         err ("do_p1_extern:  Missing memno at end of file");
  923.     else if (status == 0)
  924.         err ("do_p1_extern:  Missing memno in intermediate file");
  925.     if (addrp->vtype = extsymtab[addrp->memno].extype)
  926.         addrp->vclass = CLPROC;
  927.     } /* if addrp */
  928.  
  929.     return (expptr) addrp;
  930. } /* do_p1_extern */
  931.  
  932.  
  933.  
  934.  static expptr
  935. #ifdef KR_headers
  936. do_p1_head(infile, outfile)
  937.     FILE *infile;
  938.     FILE *outfile;
  939. #else
  940. do_p1_head(FILE *infile, FILE *outfile)
  941. #endif
  942. {
  943.     int status;
  944.     int add_n_;
  945.     long class;
  946.     char storage[256];
  947.  
  948.     status = p1getd (infile, &class);
  949.     if (status == EOF)
  950.     err ("do_p1_head:  missing header class at end of file");
  951.     else if (status == 0)
  952.     err ("do_p1_head:  missing header class in p1 file");
  953.     else {
  954.     status = p1gets (infile, storage, (int)sizeof(storage));
  955.     if (status == EOF || status == 0)
  956.         storage[0] = '\0';
  957.     } /* else */
  958.  
  959.     if (class == CLPROC || class == CLMAIN) {
  960.     chainp lengths;
  961.  
  962.     add_n_ = nentry > 1;
  963.     lengths = length_comp(entries, add_n_);
  964.  
  965.     if (!add_n_ && protofile && class != CLMAIN)
  966.         protowrite(protofile, proctype, storage, entries, lengths);
  967.  
  968.     if (class == CLMAIN)
  969.         nice_printf (outfile, "/* Main program */ ");
  970.     else
  971.         nice_printf(outfile, "%s ", multitype ? "VOID"
  972.             : c_type_decl(proctype, 1));
  973.  
  974.     nice_printf(outfile, add_n_ ? "%s0_" : "%s", storage);
  975.     if (!Ansi) {
  976.         listargs(outfile, entries, add_n_, lengths);
  977.         nice_printf (outfile, "\n");
  978.         }
  979.     list_arg_types (outfile, entries, lengths, add_n_, "\n");
  980.     nice_printf (outfile, "{\n");
  981.     frchain(&lengths);
  982.     next_tab (outfile);
  983.     strcpy(this_proc_name, storage);
  984.     list_decls (outfile);
  985.  
  986.     } else if (class == CLBLOCK)
  987.         next_tab (outfile);
  988.     else
  989.     errl("do_p1_head: got class %ld", class);
  990.  
  991.     return NULL;
  992. } /* do_p1_head */
  993.  
  994.  
  995.  static expptr
  996. #ifdef KR_headers
  997. do_p1_list(infile, outfile)
  998.     FILE *infile;
  999.     FILE *outfile;
  1000. #else
  1001. do_p1_list(FILE *infile, FILE *outfile)
  1002. #endif
  1003. {
  1004.     long tag, type, count;
  1005.     int status;
  1006.     expptr result;
  1007.  
  1008.     status = p1getd (infile, &tag);
  1009.     if (status == EOF)
  1010.     err ("do_p1_list:  missing list tag at end of file");
  1011.     else if (status == 0)
  1012.     err ("do_p1_list:  missing list tag in p1 file");
  1013.     else {
  1014.     status = p1getd (infile, &type);
  1015.     if (status == EOF)
  1016.         err ("do_p1_list:  missing list type at end of file");
  1017.     else if (status == 0)
  1018.         err ("do_p1_list:  missing list type in p1 file");
  1019.     else {
  1020.         status = p1getd (infile, &count);
  1021.         if (status == EOF)
  1022.         err ("do_p1_list:  missing count at end of file");
  1023.         else if (status == 0)
  1024.         err ("do_p1_list:  missing count in p1 file");
  1025.     } /* else */
  1026.     } /* else */
  1027.  
  1028.     result = (expptr) ALLOC (Listblock);
  1029.     if (result) {
  1030.     chainp pointer;
  1031.  
  1032.     result -> tag = tag;
  1033.     result -> listblock.vtype = type;
  1034.  
  1035. /* Assume there will be enough data */
  1036.  
  1037.     if (count--) {
  1038.         pointer = result->listblock.listp =
  1039.         mkchain((char *)do_format(infile, outfile), CHNULL);
  1040.         while (count--) {
  1041.         pointer -> nextp =
  1042.             mkchain((char *)do_format(infile, outfile), CHNULL);
  1043.         pointer = pointer -> nextp;
  1044.         } /* while (count--) */
  1045.     } /* if (count) */
  1046.     } /* if (result) */
  1047.  
  1048.     return result;
  1049. } /* do_p1_list */
  1050.  
  1051.  
  1052.  chainp
  1053. #ifdef KR_headers
  1054. length_comp(e, add_n)
  1055.     struct Entrypoint *e;
  1056.     int add_n;
  1057. #else
  1058. length_comp(struct Entrypoint *e, int add_n)
  1059. #endif
  1060.         /* get lengths of characters args */
  1061. {
  1062.     chainp lengths;
  1063.     chainp args, args1;
  1064.     Namep arg, np;
  1065.     int nchargs;
  1066.     Argtypes *at;
  1067.     Atype *a;
  1068.     extern int init_ac[TYSUBR+1];
  1069.  
  1070.     if (!e)
  1071.         return 0;    /* possible only with errors */
  1072.     args = args1 = add_n ? allargs : e->arglist;
  1073.     nchargs = 0;
  1074.     for (lengths = NULL; args; args = args -> nextp)
  1075.         if (arg = (Namep)args->datap) {
  1076.             if (arg->vclass == CLUNKNOWN)
  1077.                 arg->vclass = CLVAR;
  1078.             if (arg->vtype == TYCHAR && arg->vclass != CLPROC) {
  1079.                 lengths = mkchain((char *)arg, lengths);
  1080.                 nchargs++;
  1081.                 }
  1082.             }
  1083.     if (!add_n && (np = e->enamep)) {
  1084.         /* one last check -- by now we know all we ever will
  1085.          * about external args...
  1086.          */
  1087.         save_argtypes(e->arglist, &e->entryname->arginfo,
  1088.             &np->arginfo, 0, np->fvarname, STGEXT, nchargs,
  1089.             np->vtype, 1);
  1090.         at = e->entryname->arginfo;
  1091.         a = at->atypes + init_ac[np->vtype];
  1092.         for(; args1; a++, args1 = args1->nextp) {
  1093.             frchain(&a->cp);
  1094.             if (arg = (Namep)args1->datap)
  1095.                 switch(arg->vclass) {
  1096.                 case CLPROC:
  1097.                     if (arg->vimpltype
  1098.                     && a->type >= 300)
  1099.                         a->type = TYUNKNOWN + 200;
  1100.                     break;
  1101.                 case CLUNKNOWN:
  1102.                     a->type %= 100;
  1103.                 }
  1104.             }
  1105.         }
  1106.     return revchain(lengths);
  1107.     }
  1108.  
  1109.  void
  1110. #ifdef KR_headers
  1111. listargs(outfile, entryp, add_n_, lengths)
  1112.     FILE *outfile;
  1113.     struct Entrypoint *entryp;
  1114.     int add_n_;
  1115.     chainp lengths;
  1116. #else
  1117. listargs(FILE *outfile, struct Entrypoint *entryp, int add_n_, chainp lengths)
  1118. #endif
  1119. {
  1120.     chainp args;
  1121.     char *s;
  1122.     Namep arg;
  1123.     int did_one = 0;
  1124.  
  1125.     nice_printf (outfile, "(");
  1126.  
  1127.     if (add_n_) {
  1128.         nice_printf(outfile, "n__");
  1129.         did_one = 1;
  1130.         args = allargs;
  1131.         }
  1132.     else {
  1133.         if (!entryp)
  1134.             return;    /* possible only with errors */
  1135.         args = entryp->arglist;
  1136.         }
  1137.  
  1138.     if (multitype)
  1139.         {
  1140.         nice_printf(outfile, ", ret_val");
  1141.         did_one = 1;
  1142.         args = allargs;
  1143.         }
  1144.     else if (ONEOF(proctype, MSKCOMPLEX|MSKCHAR))
  1145.         {
  1146.         s = xretslot[proctype]->user.ident;
  1147.         nice_printf(outfile, did_one ? ", %s" : "%s",
  1148.             *s == '(' /*)*/ ? "r_v" : s);
  1149.         did_one = 1;
  1150.         if (proctype == TYCHAR)
  1151.             nice_printf (outfile, ", ret_val_len");
  1152.         }
  1153.     for (; args; args = args -> nextp)
  1154.         if (arg = (Namep)args->datap) {
  1155.             nice_printf (outfile, "%s", did_one ? ", " : "");
  1156.             out_name (outfile, arg);
  1157.             did_one = 1;
  1158.             }
  1159.  
  1160.     for (args = lengths; args; args = args -> nextp)
  1161.         nice_printf(outfile, ", %s",
  1162.             new_arg_length((Namep)args->datap));
  1163.     nice_printf (outfile, ")");
  1164. } /* listargs */
  1165.  
  1166.  
  1167.  void
  1168. #ifdef KR_headers
  1169. list_arg_types(outfile, entryp, lengths, add_n_, finalnl)
  1170.     FILE *outfile;
  1171.     struct Entrypoint *entryp;
  1172.     chainp lengths;
  1173.     int add_n_;
  1174.     char *finalnl;
  1175. #else
  1176. list_arg_types(FILE *outfile, struct Entrypoint *entryp, chainp lengths, int add_n_, char *finalnl)
  1177. #endif
  1178. {
  1179.     chainp args;
  1180.     int last_type = -1, last_class = -1;
  1181.     int did_one = 0, done_one, is_ext;
  1182.     char *s, *sep = "", *sep1;
  1183.  
  1184.     if (outfile == (FILE *) NULL) {
  1185.     err ("list_arg_types:  null output file");
  1186.     return;
  1187.     } else if (entryp == (struct Entrypoint *) NULL) {
  1188.     err ("list_arg_types:  null procedure entry pointer");
  1189.     return;
  1190.     } /* else */
  1191.  
  1192.     if (Ansi) {
  1193.     done_one = 0;
  1194.     sep1 = ", ";
  1195.     nice_printf(outfile, "(" /*)*/);
  1196.     }
  1197.     else {
  1198.     done_one = 1;
  1199.     sep1 = ";\n";
  1200.     }
  1201.     args = entryp->arglist;
  1202.     if (add_n_) {
  1203.     nice_printf(outfile, "int n__");
  1204.     did_one = done_one;
  1205.     sep = sep1;
  1206.     args = allargs;
  1207.     }
  1208.     if (multitype) {
  1209.     nice_printf(outfile, "%sMultitype *ret_val", sep);
  1210.     did_one = done_one;
  1211.     sep = sep1;
  1212.     }
  1213.     else if (ONEOF (proctype, MSKCOMPLEX|MSKCHAR)) {
  1214.     s = xretslot[proctype]->user.ident;
  1215.     nice_printf(outfile, "%s%s *%s", sep, c_type_decl(proctype, 0),
  1216.             *s == '(' /*)*/ ? "r_v" : s);
  1217.     did_one = done_one;
  1218.     sep = sep1;
  1219.     if (proctype == TYCHAR)
  1220.         nice_printf (outfile, "%sftnlen ret_val_len", sep);
  1221.     } /* if ONEOF proctype */
  1222.     for (; args; args = args -> nextp) {
  1223.     Namep arg = (Namep) args->datap;
  1224.  
  1225. /* Scalars are passed by reference, and arrays will have their lower bound
  1226.    adjusted, so nearly everything is printed with a star in front.  The
  1227.    exception is character lengths, which are passed by value. */
  1228.  
  1229.     if (arg) {
  1230.         int type = arg -> vtype, class = arg -> vclass;
  1231.  
  1232.         if (class == CLPROC)
  1233.         if (arg->vimpltype)
  1234.             type = Castargs ? TYUNKNOWN : TYSUBR;
  1235.         else if (type == TYREAL && forcedouble && !Castargs)
  1236.             type = TYDREAL;
  1237.  
  1238.         if (type == last_type && class == last_class && did_one)
  1239.         nice_printf (outfile, ", ");
  1240.         else
  1241.         if ((is_ext = class == CLPROC) && Castargs)
  1242.             nice_printf(outfile, "%s%s ", sep,
  1243.                 usedcasts[type] = casttypes[type]);
  1244.         else
  1245.             nice_printf(outfile, "%s%s ", sep,
  1246.                 c_type_decl(type, is_ext));
  1247.         if (class == CLPROC)
  1248.         if (Castargs)
  1249.             out_name(outfile, arg);
  1250.         else {
  1251.             nice_printf(outfile, "(*");
  1252.             out_name(outfile, arg);
  1253.             nice_printf(outfile, ") %s", parens);
  1254.             }
  1255.         else {
  1256.         nice_printf (outfile, "*");
  1257.         out_name (outfile, arg);
  1258.         }
  1259.  
  1260.         last_type = type;
  1261.         last_class = class;
  1262.         did_one = done_one;
  1263.         sep = sep1;
  1264.     } /* if (arg) */
  1265.     } /* for args = entryp -> arglist */
  1266.  
  1267.     for (args = lengths; args; args = args -> nextp)
  1268.     nice_printf(outfile, "%sftnlen %s", sep,
  1269.             new_arg_length((Namep)args->datap));
  1270.     if (did_one)
  1271.     nice_printf (outfile, ";\n");
  1272.     else if (Ansi)
  1273.     nice_printf(outfile,
  1274.         /*((*/ sep != sep1 && Ansi == 1 ? "void)%s" : ")%s",
  1275.         finalnl);
  1276. } /* list_arg_types */
  1277.  
  1278.  static void
  1279. #ifdef KR_headers
  1280. write_formats(outfile)
  1281.     FILE *outfile;
  1282. #else
  1283. write_formats(FILE *outfile)
  1284. #endif
  1285. {
  1286.     register struct Labelblock *lp;
  1287.     int first = 1;
  1288.     char *fs;
  1289.  
  1290.     for(lp = labeltab ; lp < highlabtab ; ++lp)
  1291.         if (lp->fmtlabused) {
  1292.             if (first) {
  1293.                 first = 0;
  1294.                 nice_printf(outfile, "/* Format strings */\n");
  1295.                 }
  1296.             nice_printf(outfile, "static char fmt_%ld[] = \"",
  1297.                 lp->stateno);
  1298.             if (!(fs = lp->fmtstring))
  1299.                 fs = "";
  1300.             nice_printf(outfile, "%s\";\n", fs);
  1301.             }
  1302.     if (!first)
  1303.         nice_printf(outfile, "\n");
  1304.     }
  1305.  
  1306.  static void
  1307. #ifdef KR_headers
  1308. write_ioblocks(outfile)
  1309.     FILE *outfile;
  1310. #else
  1311. write_ioblocks(FILE *outfile)
  1312. #endif
  1313. {
  1314.     register iob_data *L;
  1315.     register char *f, **s, *sep;
  1316.  
  1317.     nice_printf(outfile, "/* Fortran I/O blocks */\n");
  1318.     L = iob_list = (iob_data *)revchain((chainp)iob_list);
  1319.     do {
  1320.         nice_printf(outfile, "static %s %s = { ",
  1321.             L->type, L->name);
  1322.         sep = 0;
  1323.         for(s = L->fields; f = *s; s++) {
  1324.             if (sep)
  1325.                 nice_printf(outfile, sep);
  1326.             sep = ", ";
  1327.             if (*f == '"') {    /* kludge */
  1328.                 nice_printf(outfile, "\"");
  1329.                 nice_printf(outfile, "%s\"", f+1);
  1330.                 }
  1331.             else
  1332.                 nice_printf(outfile, "%s", f);
  1333.             }
  1334.         nice_printf(outfile, " };\n");
  1335.         }
  1336.         while(L = L->next);
  1337.     nice_printf(outfile, "\n\n");
  1338.     }
  1339.  
  1340.  static void
  1341. #ifdef KR_headers
  1342. write_assigned_fmts(outfile)
  1343.     FILE *outfile;
  1344. #else
  1345. write_assigned_fmts(FILE *outfile)
  1346. #endif
  1347. {
  1348.     register chainp cp;
  1349.     Namep np;
  1350.     int did_one = 0;
  1351.  
  1352.     cp = assigned_fmts = revchain(assigned_fmts);
  1353.     nice_printf(outfile, "/* Assigned format variables */\nchar ");
  1354.     do {
  1355.         np = (Namep)cp->datap;
  1356.         if (did_one)
  1357.             nice_printf(outfile, ", ");
  1358.         did_one = 1;
  1359.         nice_printf(outfile, "*%s_fmt", np->fvarname);
  1360.         }
  1361.         while(cp = cp->nextp);
  1362.     nice_printf(outfile, ";\n\n");
  1363.     }
  1364.  
  1365.  static char *
  1366. #ifdef KR_headers
  1367. to_upper(s)
  1368.     register char *s;
  1369. #else
  1370. to_upper(register char *s)
  1371. #endif
  1372. {
  1373.     static char buf[64];
  1374.     register char *t = buf;
  1375.     register int c;
  1376.     while(*t++ = (c = *s++) >= 'a' && c <= 'z' ? c + 'A' - 'a' : c);
  1377.     return buf;
  1378.     }
  1379.  
  1380.  
  1381. /* This routine creates static structures representing a namelist.
  1382.    Declarations of the namelist and related structures are:
  1383.  
  1384.     struct Vardesc {
  1385.         char *name;
  1386.         char *addr;
  1387.         ftnlen *dims;    /* laid out as struct dimensions below *//*
  1388.         int  type;
  1389.         };
  1390.     typedef struct Vardesc Vardesc;
  1391.  
  1392.     struct Namelist {
  1393.         char *name;
  1394.         Vardesc **vars;
  1395.         int nvars;
  1396.         };
  1397.  
  1398.     struct dimensions
  1399.         {
  1400.         ftnlen numberofdimensions;
  1401.         ftnlen numberofelements
  1402.         ftnlen baseoffset;
  1403.         ftnlen span[numberofdimensions-1];
  1404.         };
  1405.  
  1406.    If dims is not null, then the corner element of the array is at
  1407.    addr.  However,  the element with subscripts (i1,...,in) is at
  1408.    addr + sizeoftype * (i1+span[0]*(i2+span[1]*...) - dimp->baseoffset)
  1409. */
  1410.  
  1411.  static void
  1412. #ifdef KR_headers
  1413. write_namelists(nmch, outfile)
  1414.     chainp nmch;
  1415.     FILE *outfile;
  1416. #else
  1417. write_namelists(chainp nmch, FILE *outfile)
  1418. #endif
  1419. {
  1420.     Namep var;
  1421.     struct Hashentry *entry;
  1422.     struct Dimblock *dimp;
  1423.     int i, nd, type;
  1424.     char *comma, *name;
  1425.     register chainp q;
  1426.     register Namep v;
  1427.     extern int typeconv[];
  1428.  
  1429.     nice_printf(outfile, "/* Namelist stuff */\n\n");
  1430.     for (entry = hashtab; entry < lasthash; ++entry) {
  1431.         if (!(v = entry->varp) || !v->vnamelist)
  1432.             continue;
  1433.         type = v->vtype;
  1434.         name = v->cvarname;
  1435.         if (dimp = v->vdim) {
  1436.             nd = dimp->ndim;
  1437.             nice_printf(outfile,
  1438.                 "static ftnlen %s_dims[] = { %d, %ld, %ld",
  1439.                 name, nd,
  1440.                 dimp->nelt->constblock.Const.ci,
  1441.                 dimp->baseoffset->constblock.Const.ci);
  1442.             for(i = 0, --nd; i < nd; i++)
  1443.                 nice_printf(outfile, ", %ld",
  1444.                   dimp->dims[i].dimsize->constblock.Const.ci);
  1445.             nice_printf(outfile, " };\n");
  1446.             }
  1447.         nice_printf(outfile, "static Vardesc %s_dv = { \"%s\", %s",
  1448.             name, to_upper(v->fvarname),
  1449.             type == TYCHAR ? ""
  1450.                 : (dimp || oneof_stg(v,v->vstg,
  1451.                     M(STGEQUIV)|M(STGCOMMON)))
  1452.                 ? "(char *)" : "(char *)&");
  1453.         out_name(outfile, v);
  1454.         nice_printf(outfile, dimp ? ", %s_dims" : ", (ftnlen *)0", name);
  1455.         nice_printf(outfile, ", %ld };\n",
  1456.             type != TYCHAR  ? (long)typeconv[type]
  1457.                     : -v->vleng->constblock.Const.ci);
  1458.         }
  1459.  
  1460.     do {
  1461.         var = (Namep)nmch->datap;
  1462.         name = var->cvarname;
  1463.         nice_printf(outfile, "\nstatic Vardesc *%s_vl[] = ", name);
  1464.         comma = "{";
  1465.         i = 0;
  1466.         for(q = var->varxptr.namelist ; q ; q = q->nextp) {
  1467.             v = (Namep)q->datap;
  1468.             if (!v->vnamelist)
  1469.                 continue;
  1470.             i++;
  1471.             nice_printf(outfile, "%s &%s_dv", comma, v->cvarname);
  1472.             comma = ",";
  1473.             }
  1474.         nice_printf(outfile, " };\n");
  1475.         nice_printf(outfile,
  1476.             "static Namelist %s = { \"%s\", %s_vl, %d };\n",
  1477.             name, to_upper(var->fvarname), name, i);
  1478.         }
  1479.         while(nmch = nmch->nextp);
  1480.     nice_printf(outfile, "\n");
  1481.     }
  1482.  
  1483. /* fixextype tries to infer from usage in previous procedures
  1484.    the type of an external procedure declared
  1485.    external and passed as an argument but never typed or invoked.
  1486.  */
  1487.  
  1488.  static int
  1489. #ifdef KR_headers
  1490. fixexttype(var)
  1491.     Namep var;
  1492. #else
  1493. fixexttype(Namep var)
  1494. #endif
  1495. {
  1496.     Extsym *e;
  1497.     int type, type1;
  1498.  
  1499.     type = var->vtype;
  1500.     e = &extsymtab[var->vardesc.varno];
  1501.     if ((type1 = e->extype) && type == TYUNKNOWN)
  1502.         return var->vtype = type1;
  1503.     if (var->visused) {
  1504.         if (e->exused && type != type1)
  1505.             changedtype(var);
  1506.         e->exused = 1;
  1507.         e->extype = type;
  1508.         }
  1509.     return type;
  1510.     }
  1511.  
  1512.  static void
  1513. #ifdef KR_headers
  1514. ref_defs(outfile, refdefs)
  1515.     FILE *outfile;
  1516.     chainp refdefs;
  1517. #else
  1518. ref_defs(FILE *outfile, chainp refdefs)
  1519. #endif
  1520. {
  1521.     chainp cp;
  1522.     int eb, i, j, n;
  1523.     struct Dimblock *dimp;
  1524.     expptr b, vl;
  1525.     Namep var;
  1526.     char *amp, *comma;
  1527.  
  1528.     margin_printf(outfile, "\n");
  1529.     for(cp = refdefs = revchain(refdefs); cp; cp = cp->nextp) {
  1530.         var = (Namep)cp->datap;
  1531.         cp->datap = 0;
  1532.         amp = "_subscr";
  1533.         if (!(eb = var->vsubscrused)) {
  1534.             var->vrefused = 0;
  1535.             if (!ISCOMPLEX(var->vtype))
  1536.                 amp = "_ref";
  1537.             }
  1538.         def_start(outfile, var->cvarname, amp, CNULL);
  1539.         dimp = var->vdim;
  1540.         vl = 0;
  1541.         comma = "(";
  1542.         amp = "";
  1543.         if (var->vtype == TYCHAR) {
  1544.             amp = "&";
  1545.             vl = var->vleng;
  1546.             if (ISCONST(vl) && vl->constblock.Const.ci == 1)
  1547.                 vl = 0;
  1548.             nice_printf(outfile, "%sa_0", comma);
  1549.             comma = ",";
  1550.             }
  1551.         n = dimp->ndim;
  1552.         for(i = 1; i <= n; i++, comma = ",")
  1553.             nice_printf(outfile, "%sa_%d", comma, i);
  1554.         nice_printf(outfile, ") %s", amp);
  1555.         if (var->vsubscrused)
  1556.             var->vsubscrused = 0;
  1557.         else if (!ISCOMPLEX(var->vtype)) {
  1558.             out_name(outfile, var);
  1559.             nice_printf(outfile, "[%s", vl ? "(" : "");
  1560.             }
  1561.         for(j = 2; j < n; j++)
  1562.             nice_printf(outfile, "(");
  1563.         while(--i > 1) {
  1564.             nice_printf(outfile, "(a_%d)%s*", i, i == n ? "" : ")");
  1565.             expr_out(outfile, cpexpr(dimp->dims[i-2].dimsize));
  1566.             nice_printf(outfile, " + ");
  1567.             }
  1568.         nice_printf(outfile, "a_1");
  1569.         if (var->vtype == TYCHAR) {
  1570.             if (vl) {
  1571.                 nice_printf(outfile, ")*");
  1572.                 expr_out(outfile, cpexpr(vl));
  1573.                 }
  1574.             nice_printf(outfile, " + a_0");
  1575.             }
  1576.         if ((var->vstg != STGARG /* || checksubs */ )
  1577.          && (b = dimp->baseoffset)) {
  1578.             b = cpexpr(b);
  1579.             if (var->vtype == TYCHAR)
  1580.                 b = mkexpr(OPSTAR, cpexpr(var->vleng), b);
  1581.             nice_printf(outfile, " - ");
  1582.             expr_out(outfile, b);
  1583.             }
  1584.         if (ISCOMPLEX(var->vtype)) {
  1585.             margin_printf(outfile, "\n");
  1586.             def_start(outfile, var->cvarname, "_ref", CNULL);
  1587.             comma = "(";
  1588.             for(i = 1; i <= n; i++, comma = ",")
  1589.                 nice_printf(outfile, "%sa_%d", comma, i);
  1590.             nice_printf(outfile, ") %s[%s_subscr",
  1591.                 var->cvarname, var->cvarname);
  1592.             comma = "(";
  1593.             for(i = 1; i <= n; i++, comma = ",")
  1594.                 nice_printf(outfile, "%sa_%d", comma, i);
  1595.             nice_printf(outfile, ")");
  1596.             }
  1597.         margin_printf(outfile, "]\n" + eb);
  1598.         }
  1599.     nice_printf(outfile, "\n");
  1600.     frchain(&refdefs);
  1601.     }
  1602.  
  1603.  void
  1604. #ifdef KR_headers
  1605. list_decls(outfile)
  1606.     FILE *outfile;
  1607. #else
  1608. list_decls(FILE *outfile)
  1609. #endif
  1610. {
  1611.     extern chainp used_builtins;
  1612.     extern struct Hashentry *hashtab;
  1613.     struct Hashentry *entry;
  1614.     int write_header = 1;
  1615.     int last_class = -1, last_stg = -1;
  1616.     Namep var;
  1617.     int Alias, Define, did_one, last_type, type;
  1618.     extern int def_equivs, useauto;
  1619.     extern chainp new_vars;    /* Compiler-generated locals */
  1620.     chainp namelists = 0, refdefs = 0;
  1621.     char *ctype;
  1622.     int useauto1 = useauto && !saveall;
  1623.     long x;
  1624.     extern int hsize;
  1625.  
  1626. /* First write out the statically initialized data */
  1627.  
  1628.     if (initfile)
  1629.     list_init_data(&initfile, initfname, outfile);
  1630.  
  1631. /* Next come formats */
  1632.     write_formats(outfile);
  1633.  
  1634. /* Now write out the system-generated identifiers */
  1635.  
  1636.     if (new_vars || nequiv) {
  1637.     chainp args, next_var, this_var;
  1638.     chainp nv[TYVOID], nv1[TYVOID];
  1639.     int i, j;
  1640.     Addrp Var;
  1641.     Namep arg;
  1642.  
  1643.     /* zap unused dimension variables */
  1644.  
  1645.     for(args = allargs; args; args = args->nextp) {
  1646.         arg = (Namep)args->datap;
  1647.         if (this_var = arg->vlastdim) {
  1648.             frexpr((tagptr)this_var->datap);
  1649.             this_var->datap = 0;
  1650.             }
  1651.         }
  1652.  
  1653.     /* sort new_vars by type, skipping entries just zapped */
  1654.  
  1655.     for(i = TYADDR; i < TYVOID; i++)
  1656.         nv[i] = 0;
  1657.     for(this_var = new_vars; this_var; this_var = next_var) {
  1658.         next_var = this_var->nextp;
  1659.         if (Var = (Addrp)this_var->datap) {
  1660.             if (!(this_var->nextp = nv[j = Var->vtype]))
  1661.                 nv1[j] = this_var;
  1662.             nv[j] = this_var;
  1663.             }
  1664.         else {
  1665.             this_var->nextp = 0;
  1666.             frchain(&this_var);
  1667.             }
  1668.         }
  1669.     new_vars = 0;
  1670.     for(i = TYVOID; --i >= TYADDR;)
  1671.         if (this_var = nv[i]) {
  1672.             nv1[i]->nextp = new_vars;
  1673.             new_vars = this_var;
  1674.             }
  1675.  
  1676.     /* write the declarations */
  1677.  
  1678.     did_one = 0;
  1679.     last_type = -1;
  1680.  
  1681.     for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
  1682.         Var = (Addrp) this_var->datap;
  1683.  
  1684.         if (Var == (Addrp) NULL)
  1685.         err ("list_decls:  null variable");
  1686.         else if (Var -> tag != TADDR)
  1687.         erri ("list_decls:  bad tag on new variable '%d'",
  1688.             Var -> tag);
  1689.  
  1690.         type = nv_type (Var);
  1691.         if (Var->vstg == STGINIT
  1692.         ||  Var->uname_tag == UNAM_IDENT
  1693.             && *Var->user.ident == ' '
  1694.             && multitype)
  1695.         continue;
  1696.         if (!did_one)
  1697.         nice_printf (outfile, "/* System generated locals */\n");
  1698.  
  1699.         if (last_type == type && did_one)
  1700.         nice_printf (outfile, ", ");
  1701.         else {
  1702.         if (did_one)
  1703.             nice_printf (outfile, ";\n");
  1704.         nice_printf (outfile, "%s ",
  1705.             c_type_decl (type, Var -> vclass == CLPROC));
  1706.         } /* else */
  1707.  
  1708. /* Character type is really a string type.  Put out a '*' for parameters
  1709.    with unknown length and functions returning character */
  1710.  
  1711.         if (Var -> vtype == TYCHAR && (!ISICON ((Var -> vleng))
  1712.             || Var -> vclass == CLPROC))
  1713.         nice_printf (outfile, "*");
  1714.  
  1715.         write_nv_ident(outfile, (Addrp)this_var->datap);
  1716.         if (Var -> vtype == TYCHAR && Var->vclass != CLPROC &&
  1717.             ISICON((Var -> vleng))
  1718.             && (i = Var->vleng->constblock.Const.ci) > 0)
  1719.         nice_printf (outfile, "[%d]", i);
  1720.  
  1721.         did_one = 1;
  1722.         last_type = nv_type (Var);
  1723.     } /* for this_var */
  1724.  
  1725. /* Handle the uninitialized equivalences */
  1726.  
  1727.     do_uninit_equivs (outfile, &did_one);
  1728.  
  1729.     if (did_one)
  1730.         nice_printf (outfile, ";\n\n");
  1731.     } /* if new_vars */
  1732.  
  1733. /* Write out builtin declarations */
  1734.  
  1735.     if (used_builtins) {
  1736.     chainp cp;
  1737.     Extsym *es;
  1738.  
  1739.     last_type = -1;
  1740.     did_one = 0;
  1741.  
  1742.     nice_printf (outfile, "/* Builtin functions */");
  1743.  
  1744.     for (cp = used_builtins; cp; cp = cp -> nextp) {
  1745.         Addrp e = (Addrp)cp->datap;
  1746.  
  1747.         switch(type = e->vtype) {
  1748.         case TYDREAL:
  1749.         case TYREAL:
  1750.             /* if (forcedouble || e->dbl_builtin) */
  1751.             /* libF77 currently assumes everything double */
  1752.             type = TYDREAL;
  1753.             ctype = "double";
  1754.             break;
  1755.         case TYCOMPLEX:
  1756.         case TYDCOMPLEX:
  1757.             type = TYVOID;
  1758.             /* no break */
  1759.         default:
  1760.             ctype = c_type_decl(type, 0);
  1761.         }
  1762.  
  1763.         if (did_one && last_type == type)
  1764.         nice_printf(outfile, ", ");
  1765.         else
  1766.         nice_printf(outfile, "%s\n%s ", did_one ? ";" : "", ctype);
  1767.  
  1768.         extern_out(outfile, es = &extsymtab[e -> memno]);
  1769.         proto(outfile, es->arginfo, es->fextname);
  1770.         last_type = type;
  1771.         did_one = 1;
  1772.     } /* for cp = used_builtins */
  1773.  
  1774.     nice_printf (outfile, ";\n\n");
  1775.     } /* if used_builtins */
  1776.  
  1777.     last_type = -1;
  1778.     for (entry = hashtab; entry < lasthash; ++entry) {
  1779.     var = entry -> varp;
  1780.  
  1781.     if (var) {
  1782.         int procclass = var -> vprocclass;
  1783.         char *comment = NULL;
  1784.         int stg = var -> vstg;
  1785.         int class = var -> vclass;
  1786.         type = var -> vtype;
  1787.  
  1788.         if (var->vrefused)
  1789.         refdefs = mkchain((char *)var, refdefs);
  1790.         if (var->vsubscrused)
  1791.         if (ISCOMPLEX(var->vtype))
  1792.             var->vsubscrused = 0;
  1793.         else
  1794.             refdefs = mkchain((char *)var, refdefs);
  1795.         if (ONEOF(stg, M(STGARG)|M(STGLENG)|M(STGINIT)))
  1796.         continue;
  1797.  
  1798.         if (useauto1 && stg == STGBSS && !var->vsave)
  1799.         stg = STGAUTO;
  1800.  
  1801.         switch (class) {
  1802.             case CLVAR:
  1803.             break;
  1804.         case CLPROC:
  1805.             switch(procclass) {
  1806.             case PTHISPROC:
  1807.                 extsymtab[var->vardesc.varno].extype = type;
  1808.                 continue;
  1809.             case PSTFUNCT:
  1810.             case PINTRINSIC:
  1811.                 continue;
  1812.             case PUNKNOWN:
  1813.                 err ("list_decls:  unknown procedure class");
  1814.                 continue;
  1815.             case PEXTERNAL:
  1816.                 if (stg == STGUNKNOWN) {
  1817.                     warn1(
  1818.                     "%.64s declared EXTERNAL but never used.",
  1819.                         var->fvarname);
  1820.                     /* to retain names declared EXTERNAL */
  1821.                     /* but not referenced, change
  1822.                     /* "continue" to "stg = STGEXT" */
  1823.                     continue;
  1824.                     }
  1825.                 else
  1826.                     type = fixexttype(var);
  1827.             }
  1828.             break;
  1829.         case CLUNKNOWN:
  1830.             /* declared but never used */
  1831.             continue;
  1832.         case CLPARAM:
  1833.             continue;
  1834.         case CLNAMELIST:
  1835.             if (var->visused)
  1836.                 namelists = mkchain((char *)var, namelists);
  1837.             continue;
  1838.         default:
  1839.             erri("list_decls:  can't handle class '%d' yet",
  1840.                 class);
  1841.             Fatal(var->fvarname);
  1842.             continue;
  1843.         } /* switch */
  1844.  
  1845.         /* Might be equivalenced to a common.  If not, don't process */
  1846.         if (stg == STGCOMMON && !var->vcommequiv)
  1847.         continue;
  1848.  
  1849. /* Only write the header if system-generated locals, builtins, or
  1850.    uninitialized equivs were already output */
  1851.  
  1852.         if (write_header == 1 && (new_vars || nequiv || used_builtins)
  1853.             && oneof_stg ( var, stg,
  1854.             M(STGBSS)|M(STGEXT)|M(STGAUTO)|M(STGCOMMON)|M(STGEQUIV))) {
  1855.         nice_printf (outfile, "/* Local variables */\n");
  1856.         write_header = 2;
  1857.         }
  1858.  
  1859.  
  1860.         Alias = oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON));
  1861.         if (Define = (Alias && def_equivs)) {
  1862.         if (!write_header)
  1863.             nice_printf(outfile, ";\n");
  1864.         def_start(outfile, var->cvarname, CNULL, "(");
  1865.         goto Alias1;
  1866.         }
  1867.         else if (type == last_type && class == last_class &&
  1868.             stg == last_stg && !write_header)
  1869.         nice_printf (outfile, ", ");
  1870.         else {
  1871.         if (!write_header && ONEOF(stg, M(STGBSS)|
  1872.             M(STGEXT)|M(STGAUTO)|M(STGEQUIV)|M(STGCOMMON)))
  1873.             nice_printf (outfile, ";\n");
  1874.  
  1875.         switch (stg) {
  1876.             case STGARG:
  1877.             case STGLENG:
  1878.             /* Part of the argument list, don't write them out
  1879.                again */
  1880.             continue;        /* Go back to top of the loop */
  1881.             case STGBSS:
  1882.             case STGEQUIV:
  1883.             case STGCOMMON:
  1884.             nice_printf (outfile, "static ");
  1885.             break;
  1886.             case STGEXT:
  1887.             nice_printf (outfile, "extern ");
  1888.             break;
  1889.             case STGAUTO:
  1890.             break;
  1891.             case STGINIT:
  1892.             case STGUNKNOWN:
  1893.             /* Don't want to touch the initialized data, that will
  1894.                be handled elsewhere.  Unknown data have
  1895.                already been complained about, so skip them */
  1896.             continue;
  1897.             default:
  1898.             erri("list_decls:  can't handle storage class %d",
  1899.                 stg);
  1900.             continue;
  1901.         } /* switch */
  1902.  
  1903.         if (type == TYCHAR && halign && class != CLPROC
  1904.         && ISICON(var->vleng)) {
  1905.             nice_printf(outfile, "struct { %s fill; char val",
  1906.                 halign);
  1907.             x = wr_char_len(outfile, var->vdim,
  1908.                 var->vleng->constblock.Const.ci, 1);
  1909.             if (x %= hsize)
  1910.                 nice_printf(outfile, "; char fill2[%ld]",
  1911.                     hsize - x);
  1912.             nice_printf(outfile, "; } %s_st;\n", var->cvarname);
  1913.             def_start(outfile, var->cvarname, CNULL, var->cvarname);
  1914.             margin_printf(outfile, "_st.val\n");
  1915.             last_type = -1;
  1916.             write_header = 2;
  1917.             continue;
  1918.             }
  1919.         nice_printf(outfile, "%s ",
  1920.             c_type_decl(type, class == CLPROC));
  1921.         } /* else */
  1922.  
  1923. /* Character type is really a string type.  Put out a '*' for variable
  1924.    length strings, and also for equivalences */
  1925.  
  1926.         if (type == TYCHAR && class != CLPROC
  1927.             && (!var->vleng || !ISICON (var -> vleng))
  1928.         || oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON)))
  1929.         nice_printf (outfile, "*%s", var->cvarname);
  1930.         else {
  1931.         nice_printf (outfile, "%s", var->cvarname);
  1932.         if (class == CLPROC) {
  1933.             Argtypes *at;
  1934.             if (!(at = var->arginfo)
  1935.              && var->vprocclass == PEXTERNAL)
  1936.                 at = extsymtab[var->vardesc.varno].arginfo;
  1937.             proto(outfile, at, var->fvarname);
  1938.             }
  1939.         else if (type == TYCHAR && ISICON ((var -> vleng)))
  1940.             wr_char_len(outfile, var->vdim,
  1941.                 (int)var->vleng->constblock.Const.ci, 0);
  1942.         else if (var -> vdim &&
  1943.             !oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON)))
  1944.             comment = wr_ardecls(outfile, var->vdim, 1L);
  1945.         }
  1946.  
  1947.         if (comment)
  1948.         nice_printf (outfile, "%s", comment);
  1949.  Alias1:
  1950.         if (Alias) {
  1951.         char *amp, *lp, *name, *rp;
  1952.         ftnint voff = var -> voffset;
  1953.         int et0, expr_type, k;
  1954.         Extsym *E;
  1955.         struct Equivblock *eb;
  1956.         char buf[16];
  1957.  
  1958. /* We DON'T want to use oneof_stg here, because we need to distinguish
  1959.    between them */
  1960.  
  1961.         if (stg == STGEQUIV) {
  1962.             name = equiv_name(k = var->vardesc.varno, CNULL);
  1963.             eb = eqvclass + k;
  1964.             if (eb->eqvinit) {
  1965.                 amp = "&";
  1966.                 et0 = TYERROR;
  1967.                 }
  1968.             else {
  1969.                 amp = "";
  1970.                 et0 = eb->eqvtype;
  1971.                 }
  1972.             expr_type = et0;
  1973.             }
  1974.         else {
  1975.             E = &extsymtab[var->vardesc.varno];
  1976.             sprintf(name = buf, "%s%d", E->cextname, E->curno);
  1977.             expr_type = type;
  1978.             et0 = -1;
  1979.             amp = "&";
  1980.         } /* else */
  1981.  
  1982.         if (!Define)
  1983.             nice_printf (outfile, " = ");
  1984.         if (voff) {
  1985.             k = typesize[type];
  1986.             switch((int)(voff % k)) {
  1987.                 case 0:
  1988.                     voff /= k;
  1989.                     expr_type = type;
  1990.                     break;
  1991.                 case SZSHORT:
  1992.                 case SZSHORT+SZLONG:
  1993.                     expr_type = TYSHORT;
  1994.                     voff /= SZSHORT;
  1995.                     break;
  1996.                 case SZLONG:
  1997.                     expr_type = TYLONG;
  1998.                     voff /= SZLONG;
  1999.                     break;
  2000.                 default:
  2001.                     expr_type = TYCHAR;
  2002.                 }
  2003.             }
  2004.  
  2005.         if (expr_type == type) {
  2006.             lp = rp = "";
  2007.             if (et0 == -1 && !voff)
  2008.                 goto cast;
  2009.             }
  2010.         else {
  2011.             lp = "(";
  2012.             rp = ")";
  2013.  cast:
  2014.             nice_printf(outfile, "(%s *)", c_type_decl(type, 0));
  2015.             }
  2016.  
  2017. /* Now worry about computing the offset */
  2018.  
  2019.         if (voff) {
  2020.             if (expr_type == et0)
  2021.             nice_printf (outfile, "%s%s + %ld%s",
  2022.                 lp, name, voff, rp);
  2023.             else
  2024.             nice_printf(outfile, "%s(%s *)%s%s + %ld%s", lp,
  2025.                 c_type_decl (expr_type, 0), amp,
  2026.                 name, voff, rp);
  2027.         } else
  2028.             nice_printf(outfile, "%s%s", amp, name);
  2029. /* Always put these at the end of the line */
  2030.         last_type = last_class = last_stg = -1;
  2031.         write_header = 0;
  2032.         if (Define) {
  2033.             margin_printf(outfile, ")\n");
  2034.             write_header = 2;
  2035.             }
  2036.         continue;
  2037.         }
  2038.         write_header = 0;
  2039.         last_type = type;
  2040.         last_class = class;
  2041.         last_stg = stg;
  2042.     } /* if (var) */
  2043.     } /* for (entry = hashtab */
  2044.  
  2045.     if (!write_header)
  2046.     nice_printf (outfile, ";\n\n");
  2047.     else if (write_header == 2)
  2048.     nice_printf(outfile, "\n");
  2049.  
  2050. /* Next, namelists, which may reference equivs */
  2051.  
  2052.     if (namelists) {
  2053.     write_namelists(namelists = revchain(namelists), outfile);
  2054.     frchain(&namelists);
  2055.     }
  2056.  
  2057. /* Finally, ioblocks (which may reference equivs and namelists) */
  2058.     if (iob_list)
  2059.     write_ioblocks(outfile);
  2060.     if (assigned_fmts)
  2061.     write_assigned_fmts(outfile);
  2062.  
  2063.     if (refdefs)
  2064.     ref_defs(outfile, refdefs);
  2065.  
  2066. } /* list_decls */
  2067.  
  2068.  void
  2069. #ifdef KR_headers
  2070. do_uninit_equivs(outfile, did_one)
  2071.     FILE *outfile;
  2072.     int *did_one;
  2073. #else
  2074. do_uninit_equivs(FILE *outfile, int *did_one)
  2075. #endif
  2076. {
  2077.     extern int nequiv;
  2078.     struct Equivblock *eqv, *lasteqv = eqvclass + nequiv;
  2079.     int k, last_type = -1, t;
  2080.  
  2081.     for (eqv = eqvclass; eqv < lasteqv; eqv++)
  2082.     if (!eqv -> eqvinit && eqv -> eqvtop != eqv -> eqvbottom) {
  2083.         if (!*did_one)
  2084.         nice_printf (outfile, "/* System generated locals */\n");
  2085.         t = eqv->eqvtype;
  2086.         if (last_type == t)
  2087.         nice_printf (outfile, ", ");
  2088.         else {
  2089.         if (*did_one)
  2090.             nice_printf (outfile, ";\n");
  2091.         nice_printf (outfile, "static %s ", c_type_decl(t, 0));
  2092.         k = typesize[t];
  2093.         } /* else */
  2094.         nice_printf(outfile, "%s", equiv_name((int)(eqv - eqvclass), CNULL));
  2095.         nice_printf(outfile, "[%ld]",
  2096.         (eqv->eqvtop - eqv->eqvbottom + k - 1) / k);
  2097.         last_type = t;
  2098.         *did_one = 1;
  2099.     } /* if !eqv -> eqvinit */
  2100. } /* do_uninit_equivs */
  2101.  
  2102.  
  2103. /* wr_ardecls -- Writes the brackets and size for an array
  2104.    declaration.  Because of the inner workings of the compiler,
  2105.    multi-dimensional arrays get mapped directly into a one-dimensional
  2106.    array, so we have to compute the size of the array here.  When the
  2107.    dimension is greater than 1, a string comment about the original size
  2108.    is returned */
  2109.  
  2110.  char *
  2111. #ifdef KR_headers
  2112. wr_ardecls(outfile, dimp, size)
  2113.     FILE *outfile;
  2114.     struct Dimblock *dimp;
  2115.     long size;
  2116. #else
  2117. wr_ardecls(FILE *outfile, struct Dimblock *dimp, long size)
  2118. #endif
  2119. {
  2120.     int i, k;
  2121.     ftnint j;
  2122.     static char buf[1000];
  2123.  
  2124.     if (dimp == (struct Dimblock *) NULL)
  2125.     return NULL;
  2126.  
  2127.     sprintf(buf, "\t/* was ");    /* would like to say  k = sprintf(...), but */
  2128.     k = strlen(buf);        /* BSD doesn't return char transmitted count */
  2129.  
  2130.     for (i = 0; i < dimp -> ndim; i++) {
  2131.     expptr this_size = dimp -> dims[i].dimsize;
  2132.  
  2133.     if (ISCONST(this_size)) {
  2134.         if (ISINT(this_size->constblock.vtype))
  2135.             j = this_size -> constblock.Const.ci;
  2136.         else if (ISREAL(this_size->constblock.vtype))
  2137.             j = (ftnint)this_size -> constblock.Const.cd[0];
  2138.         else
  2139.             goto non_const;
  2140.         size *= j;
  2141.            sprintf(buf+k, "[%ld]", j);
  2142.             k += strlen(buf+k);
  2143.         /* BSD prevents getting strlen from sprintf */
  2144.         }
  2145.     else {
  2146.  non_const:
  2147.         err ("wr_ardecls:  nonconstant array size");
  2148.         }
  2149.     } /* for i = 0 */
  2150.  
  2151.     nice_printf (outfile, "[%ld]", size);
  2152.     strcat(buf+k, " */");
  2153.  
  2154.     return (i > 1) ? buf : NULL;
  2155. } /* wr_ardecls */
  2156.  
  2157.  
  2158.  
  2159. /* ----------------------------------------------------------------------
  2160.  
  2161.     The following routines read from the p1 intermediate file.  If
  2162.    that format changes, only these routines need be changed
  2163.  
  2164.    ---------------------------------------------------------------------- */
  2165.  
  2166.  static int
  2167. #ifdef KR_headers
  2168. get_p1_token(infile)
  2169.     FILE *infile;
  2170. #else
  2171. get_p1_token(FILE *infile)
  2172. #endif
  2173. {
  2174.     int token = P1_UNKNOWN;
  2175.  
  2176. /* NOT PORTABLE!! */
  2177.  
  2178.     if (fscanf (infile, "%d", &token) == EOF)
  2179.     return P1_EOF;
  2180.  
  2181. /* Skip over the ": " */
  2182.  
  2183.     if (getc (infile) != '\n')
  2184.     getc (infile);
  2185.  
  2186.     return token;
  2187. } /* get_p1_token */
  2188.  
  2189.  
  2190.  
  2191. /* Returns a (null terminated) string from the input file */
  2192.  
  2193.  static int
  2194. #ifdef KR_headers
  2195. p1gets(fp, str, size)
  2196.     FILE *fp;
  2197.     char *str;
  2198.     int size;
  2199. #else
  2200. p1gets(FILE *fp, char *str, int size)
  2201. #endif
  2202. {
  2203.     char c;
  2204.  
  2205.     if (str == NULL)
  2206.     return 0;
  2207.  
  2208.     if ((c = getc (fp)) != ' ')
  2209.     ungetc (c, fp);
  2210.  
  2211.     if (fgets (str, size, fp)) {
  2212.     int length;
  2213.  
  2214.     str[size - 1] = '\0';
  2215.     length = strlen (str);
  2216.  
  2217. /* Get rid of the newline */
  2218.  
  2219.     if (str[length - 1] == '\n')
  2220.         str[length - 1] = '\0';
  2221.     return 1;
  2222.  
  2223.     } else if (feof (fp))
  2224.     return EOF;
  2225.     else
  2226.     return 0;
  2227. } /* p1gets */
  2228.  
  2229.  
  2230.  static int
  2231. #ifdef KR_headers
  2232. p1get_const(infile, type, resultp)
  2233.     FILE *infile;
  2234.     int type;
  2235.     struct Constblock **resultp;
  2236. #else
  2237. p1get_const(FILE *infile, int type, struct Constblock **resultp)
  2238. #endif
  2239. {
  2240.     int status;
  2241.     struct Constblock *result;
  2242.  
  2243.     if (type != TYCHAR) {
  2244.         *resultp = result = ALLOC(Constblock);
  2245.         result -> tag = TCONST;
  2246.         result -> vtype = type;
  2247.         }
  2248.  
  2249.     switch (type) {
  2250.     case TYINT1:
  2251.         case TYSHORT:
  2252.     case TYLONG:
  2253.     case TYLOGICAL:
  2254. #ifdef TYQUAD
  2255.     case TYQUAD:
  2256. #endif
  2257.     case TYLOGICAL1:
  2258.     case TYLOGICAL2:
  2259.         status = p1getd (infile, &(result -> Const.ci));
  2260.         break;
  2261.     case TYREAL:
  2262.     case TYDREAL:
  2263.         status = p1getf(infile, &result->Const.cds[0]);
  2264.         result->vstg = 1;
  2265.         break;
  2266.     case TYCOMPLEX:
  2267.     case TYDCOMPLEX:
  2268.         status = p1getf(infile, &result->Const.cds[0]);
  2269.         if (status && status != EOF)
  2270.         status = p1getf(infile, &result->Const.cds[1]);
  2271.         result->vstg = 1;
  2272.         break;
  2273.     case TYCHAR:
  2274.         status = fscanf(infile, "%lx", resultp);
  2275.         break;
  2276.     default:
  2277.         erri ("p1get_const:  bad constant type '%d'", type);
  2278.         status = 0;
  2279.         break;
  2280.     } /* switch */
  2281.  
  2282.     return status;
  2283. } /* p1get_const */
  2284.  
  2285.  static int
  2286. #ifdef KR_headers
  2287. p1getd(infile, result)
  2288.     FILE *infile;
  2289.     long *result;
  2290. #else
  2291. p1getd(FILE *infile, long *result)
  2292. #endif
  2293. {
  2294.     return fscanf (infile, "%ld", result);
  2295. } /* p1getd */
  2296.  
  2297.  static int
  2298. #ifdef KR_headers
  2299. p1getf(infile, result)
  2300.     FILE *infile;
  2301.     char **result;
  2302. #else
  2303. p1getf(FILE *infile, char **result)
  2304. #endif
  2305. {
  2306.  
  2307.     char buf[1324];
  2308.     register int k;
  2309.  
  2310.     k = fscanf (infile, "%s", buf);
  2311.     if (k < 1)
  2312.         k = EOF;
  2313.     else
  2314.         strcpy(*result = mem(strlen(buf)+1,0), buf);
  2315.     return k;
  2316. }
  2317.  
  2318.  static int
  2319. #ifdef KR_headers
  2320. p1getn(infile, count, result)
  2321.     FILE *infile;
  2322.     int count;
  2323.     char **result;
  2324. #else
  2325. p1getn(FILE *infile, int count, char **result)
  2326. #endif
  2327. {
  2328.  
  2329.     char *bufptr;
  2330.  
  2331.     bufptr = (char *) ckalloc (count);
  2332.  
  2333.     if (result)
  2334.     *result = bufptr;
  2335.  
  2336.     for (; !feof (infile) && count > 0; count--)
  2337.     *bufptr++ = getc (infile);
  2338.  
  2339.     return feof (infile) ? EOF : 1;
  2340. } /* p1getn */
  2341.  
  2342.  static void
  2343. #ifdef KR_headers
  2344. proto(outfile, at, fname)
  2345.     FILE *outfile;
  2346.     Argtypes *at;
  2347.     char *fname;
  2348. #else
  2349. proto(FILE *outfile,  Argtypes *at,  char *fname)
  2350. #endif
  2351. {
  2352.     int i, j, k, n;
  2353.     char *comma;
  2354.     Atype *atypes;
  2355.     Namep np;
  2356.     chainp cp;
  2357.  
  2358.     if (at) {
  2359.         /* Correct types that we learn on the fly, e.g.
  2360.             subroutine gotcha(foo)
  2361.             external foo
  2362.             call zap(...,foo,...)
  2363.             call foo(...)
  2364.         */
  2365.         atypes = at->atypes;
  2366.         n = at->defined ? at->dnargs : at->nargs;
  2367.         for(i = 0; i++ < n; atypes++) {
  2368.             if (!(cp = atypes->cp))
  2369.                 continue;
  2370.             j = atypes->type;
  2371.             do {
  2372.                 np = (Namep)cp->datap;
  2373.                 k = np->vtype;
  2374.                 if (np->vclass == CLPROC) {
  2375.                     if (!np->vimpltype && k)
  2376.                         k += 200;
  2377.                     else {
  2378.                         if (j >= 300)
  2379.                             j = TYUNKNOWN + 200;
  2380.                         continue;
  2381.                         }
  2382.                     }
  2383.                 if (j == k)
  2384.                     continue;
  2385.                 if (j >= 300
  2386.                 ||  j == 200 && k >= 200)
  2387.                     j = k;
  2388.                 else {
  2389.                     if (at->nargs >= 0)
  2390.                        bad_atypes(at,fname,i,j,k,""," and");
  2391.                     goto break2;
  2392.                     }
  2393.                 }
  2394.                 while(cp = cp->nextp);
  2395.             atypes->type = j;
  2396.             frchain(&atypes->cp);
  2397.             }
  2398.         }
  2399.  break2:
  2400.     if (parens) {
  2401.         nice_printf(outfile, parens);
  2402.         return;
  2403.         }
  2404.  
  2405.     if (!at || (n = at-> defined ? at->dnargs : at->nargs) < 0) {
  2406.         nice_printf(outfile, Ansi == 1 ? "()" : "(...)");
  2407.         return;
  2408.         }
  2409.  
  2410.     if (n == 0) {
  2411.         nice_printf(outfile, Ansi == 1 ? "(void)" : "()");
  2412.         return;
  2413.         }
  2414.  
  2415.     atypes = at->atypes;
  2416.     nice_printf(outfile, "(");
  2417.     comma = "";
  2418.     for(; --n >= 0; atypes++) {
  2419.         k = atypes->type;
  2420.         if (k == TYADDR)
  2421.             nice_printf(outfile, "%schar **", comma);
  2422.         else if (k >= 200) {
  2423.             k -= 200;
  2424.             nice_printf(outfile, "%s%s", comma,
  2425.                 usedcasts[k] = casttypes[k]);
  2426.             }
  2427.         else if (k >= 100)
  2428.             nice_printf(outfile,
  2429.                     k == TYCHAR + 100 ? "%s%s *" : "%s%s",
  2430.                     comma, c_type_decl(k-100, 0));
  2431.         else
  2432.             nice_printf(outfile, "%s%s *", comma,
  2433.                     c_type_decl(k, 0));
  2434.         comma = ", ";
  2435.         }
  2436.     nice_printf(outfile, ")");
  2437.     }
  2438.  
  2439.  void
  2440. #ifdef KR_headers
  2441. protowrite(protofile, type, name, e, lengths)
  2442.     FILE *protofile;
  2443.     int type;
  2444.     char *name;
  2445.     struct Entrypoint *e;
  2446.     chainp lengths;
  2447. #else
  2448. protowrite(FILE *protofile, int type, char *name, struct Entrypoint *e, chainp lengths)
  2449. #endif
  2450. {
  2451.     extern char used_rets[];
  2452.     int asave;
  2453.  
  2454.     if (!(asave = Ansi))
  2455.         Castargs = Ansi = 1;
  2456.     nice_printf(protofile, "extern %s %s", protorettypes[type], name);
  2457.     list_arg_types(protofile, e, lengths, 0, ";\n");
  2458.     used_rets[type] = 1;
  2459.     if (!(Ansi = asave))
  2460.         Castargs = 0;
  2461.     }
  2462.  
  2463.  static void
  2464. #ifdef KR_headers
  2465. do_p1_1while(outfile)
  2466.     FILE *outfile;
  2467. #else
  2468. do_p1_1while(FILE *outfile)
  2469. #endif
  2470. {
  2471.     if (*wh_next) {
  2472.         nice_printf(outfile,
  2473.             "for(;;) { /* while(complicated condition) */\n" /*}*/ );
  2474.         next_tab(outfile);
  2475.         }
  2476.     else
  2477.         nice_printf(outfile, "while(" /*)*/ );
  2478.     }
  2479.  
  2480.  static void
  2481. #ifdef KR_headers
  2482. do_p1_2while(infile, outfile)
  2483.     FILE *infile;
  2484.     FILE *outfile;
  2485. #else
  2486. do_p1_2while(FILE *infile, FILE *outfile)
  2487. #endif
  2488. {
  2489.     expptr test;
  2490.  
  2491.     test = do_format(infile, outfile);
  2492.     if (*wh_next)
  2493.         nice_printf(outfile, "if (!(");
  2494.     expr_out(outfile, test);
  2495.     if (*wh_next++)
  2496.         nice_printf(outfile, "))\n\tbreak;\n");
  2497.     else {
  2498.         nice_printf(outfile, /*(*/ ") {\n");
  2499.         next_tab(outfile);
  2500.         }
  2501.     }
  2502.  
  2503.  static void
  2504. #ifdef KR_headers
  2505. do_p1_elseifstart(outfile)
  2506.     FILE *outfile;
  2507. #else
  2508. do_p1_elseifstart(FILE *outfile)
  2509. #endif
  2510. {
  2511.     if (*ei_next++) {
  2512.         prev_tab(outfile);
  2513.         nice_printf(outfile, /*{*/
  2514.             "} else /* if(complicated condition) */ {\n" /*}*/ );
  2515.         next_tab(outfile);
  2516.         }
  2517.     }
  2518.